home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
qdir.zip
/
QDIR.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1993-01-04
|
16KB
|
411 lines
Program QuickExtendedDirectory;
{Directory listing with attributes and age of file in days shown.
See Procedure DisplaySyntax for instructions and command line switches.
This program is intentionally designed to work and look as much like the
Dos DIR command as possible, except it displays the following additional
information: 1) The file attribute, where 'R' means read-only, 'S'
means system, 'H' means hidden, and 'A' means the archive bit is set.
2) The age of the file in days. Its default (opposite of DIR) is paged
mode, wherein it stops every screenful and waits for a keypress.
This may be changed with the /p switch. It also, like DIR, defaults
to a one file per line format. This may be changed with the /w
switch, but no age in days is shown in this mode.
Placed in the public domain
Rick Housh
CIS PIN 72466,212
}
Uses Dos, Crt;
const
drive = ' drive ';
tab = ' ';
var
Fname, DirStr : string;
i, j, DriveNo : byte;
Fblock : SearchRec;
WholeName : string[12];
ch, DName : string[1];
Count : word;
DSize : longint;
Double, Paging,
DirFound, FirstTime : boolean;
Procedure DisplaySyntax; { Help, called with QDIR/H }
begin
WriteLn('QDIR : Quick Extended directory program.'#13#10);
WriteLn(
'Usage: QDIR [ filename.ext ] [ /w ] [ /p ] [ /h ]');
WriteLn(Tab,' (Default filename.ext = "*.*")'#13#10);
WriteLn(
'Shows: FileName, Attributes (Read only, Hidden, System, Archive, Directory),');
WriteLn(
' Size, Date & Time of last write, and Age of file in days.');
WriteLn(
#13#10'Switches: /w : Two per line, w/o time or age of file.');
WriteLn(Tab,' /p : NO pause between screens.');
WriteLn(Tab,' /h : This text.'#13#10);
Halt;
end;
Procedure UpString(var Strg: String);
{Upcases a string. Syntax is Upstring(whatever)}
{AnyString is String}
begin
inline
($C4/$BE/Strg/
$26/$8A/$0D/
$FE/$C1/
$FE/$C9/
$74/$13/
$47/
$26/$80/$3D/$61/
$72/$F5/
$26/$80/$3D/$7A/
$77/$EF/
$26/$80/$2D/$20/
$EB/$E9);
end; {Inline Procedure UpString}
Function GetKey : char;
var ch : char;
Begin
Inline(
{; Function GetKey : Char}
{; Clears the keyboard buffer then waits until}
{; a key is struck. If the key is a special, e.g.}
{; function key, goes back and reads the next}
{; byte in the keyboard buffer. Thus does}
{; nothing special with function keys.}
$B4/$0C { MOV AH,$0C ;Set up to clear buffer}
/$B0/$08 { MOV AL,8 ;then to get a char}
/$CD/$21 {SPCL: INT $21 ;Call DOS}
/$3C/$00 { CMP AL,0 ;If it's a 0 byte}
/$75/$04 { JNZ CHRDY ;is spec., get second byte}
/$B4/$08 { MOV AH,8 ;else set up for another}
/$EB/$F6 { JMP SHORT SPCL ;and get it}
/$88/$46/<CH {CHRDY: MOV <CH[BP],AL ;else put into function return}
);
GetKey := Ch;
end; {Inline function GetKey}
Procedure ShowIt; { Does most of the work in displaying info }
const
WeekDay: array[0..6] of String[9] = ('Sunday','Monday','Tuesday',
'Wednesday','Thursday','Friday','Saturday');
MonthName:array[1..12] of String[9] = ('January','February','March','April',
'May','June','July','August','September',
'October','November','December');
var
x : byte;
Kind : string[4];
Date, Time : string[8];
st1, st2, st3 : string[2];
DT : DateTime;
y, dy, m, DayOfWeek : word;
DayFromZero, LeapYearDays,
CurrDay, FileDay, DifferenceInDays : LongInt;
begin
UnpackTime(FBlock.Time,DT); { Make file intelligible }
GetDate(y, m, dy, DayOfWeek); { And file date }
x := Fblock.Attr; { Ready to check file attribute}
If x AND $40 <> 0 then { If bit 6 set file is device }
Begin { So tell em, and exit }
WriteLn(FName,' is a Device'#13#10);
Halt;
end; { Initialize attribute string }
Kind := ' ';
If x AND $01 <> 0 then Kind[1] := 'R'; { If read-only }
If x AND $02 <> 0 then Kind[2] := 'H'; { If hidden }
If x AND $04 <> 0 then Kind[3] := 'S'; { If system }
If x AND $20 <> 0 then Kind[4] := 'A'; { If archive bit set }
Str(DT.Month:3,St1); { Move month # into string }
Str(DT.Day:2,St2); { and day # }
If St2[1] = ' ' then St2[1] := '0'; { If leading space make it '0'}
Str(DT.Year - 1900:2,St3); { Last two digits of yr to st3}
Date := st1 + '-' + st2 + '-' + st3 + ' '; { and format date string }
If not Double then { If doing full info }
begin { Then show file create time}
Str(DT.Hour:2,st1);
Str(DT.Min:2,st2);
If st2[1] = ' ' then st2[1] := '0';
Str(DT.Sec:2,st3);
If St3[1] = ' ' then st3[1] := '0';
Time := St1 + ':' + St2 + ':' + st3 + ' ';
{ The following code calculates the age of the file (in days)
by first calculating the current number of days from
January 1, 0 A.D. for the current date (machine date),
then the number of days from 1/1/00 to the date of
the file, then subtracting the file age from the current
age. If the file date is later then the current date
the message 'FUTURE DATE', instead of the number of
days is displayed. This routine makes the necessary
adjustments for leap years, even the 4000 year adjust-
ment not covered by the Gregorian calendar rules, but
indicated necessary by the mathematics of the thing.}
DayFromZero := ( 365 * y ) + (31 * Pred(m)) + Dy ;
If m > 2 then DayFromZero := DayFromZero - Trunc(0.4 * m + 2.3)
else if m < 2 then dec(y);
LeapYearDays := (y div 4) - (y div 100)
+ (y div 400) - (y div 4000);
CurrDay := DayFromZero + LeapYearDays ;
DayFromZero :=( 365 * DT.Year) + (31 * Pred(DT.Month) + DT.Day);
If DT.Month > 2 then
DayFromZero := DayFromZero - trunc(0.4 * DT.Month + 2.3)
else if DT.Month < 2 then Dec(DT.Year);
LeapYearDays := (y div 4) - (y div 100)
+ (y div 400) - (y div 4000);
FileDay := DayFromZero + LeapYearDays ;
DifferenceInDays := (CurrDay - FileDay);
end;
{ If the program has just started Write the current date and time}
If FirstTime then Write(
Tab,Weekday[DayOfWeek],' ',MonthName[m]:2,',',
' ',dy:2,',',' ',y:4,#13#10#10);
FirstTime := False;
If not Double then Write(' '); { Leading spaces for 1 line/file}
Write(WholeName); { First write filename }
Write(' ',Kind); { then attribute }
{ Write filesize, unless it's }
{ a directory }
If x AND $10 <> 0 then Write(
' <DIR> ') else Write(Fblock.Size:7,' ');
Write(Date); { Show file date }
If not Double then Write(' ',Time); { and time, if not short form}
If not Double then { If long form show age in days}
begin
If (DifferenceInDays < 0) then
Write (' FUTURE DATE')
else
begin
Write(' Age ',DifferenceinDays:5);
Write(' day');
If (DifferenceInDays) <> 1 then Write('s');
end;
end;
Inc(Count);
If Double then { If short form and 1st on line make tab }
begin { If short form and 2nd on line do CR, LF }
if odd(Count) then Write(Tab) else WriteLn;
end
else WriteLn;
If Paging then { If the /p switch is on }
begin { and screen is full, stop, ask for keypress }
If (Double and (Count mod 46 = 0)) or
(not Double and (Count mod 23 = 0)) then
begin
Write('Press any key to continue ...');
ch := GetKey;
WriteLn;
end;
end;
end; {Procedure Showit}
Procedure CheckForDosError; { Its name is its motto }
const
nf = ' not found';
var
d : integer;
begin
d := DosError; { Get DOS error number }
DosError := 0; { and reset DosError }
If d = 0 then Exit; { If no error, exit }
Case d of { otherwise display nature of error }
2 : Write('File',nf);
3 : Write('Invalid path');
18 : Write('File',nf);
152 : Write('Drive ',Dname,' not ready');
156 : Write('Disk seek error on ',Dname);
162 : Write('General failure on',drive,Dname);
else Write('DOS Error #',d);
end; {Case}
(* { Uncomment out the next if you want error in hexidecimal }
Write(' DOS Error = ',d,' Decimal ');
Case D of
2 : Write ('2');
3 : Write ('3');
18 : Write ('12');
152 : Write ('98');
156 : Write ('9C');
162 : Write ('A2');
end; {Case}
If D in [2,3,18,152,156,162] then Write(' Hexadecimal');
*)
WriteLn;
Halt(d); { Exit with DOS errorlevel set }
end; {Procedure CheckForDosError}
Procedure GetParms; { Gets the command and formats everything to }
{ work as much like DIR as possible }
var
x : Byte;
Parm : Array[ 1..3 ] of String;
IsDir : Boolean;
Begin
Fname := '';
DirStr := '';
x := 0;
for i := 1 to 3 do
begin
If Paramcount > 0 then
begin
Parm[i] := ParamStr(i);
UpString(Parm[i]);
end
else
Parm[i] := '';
end;
Fname := Parm[1];
Double := False;
For i := 1 to 3 do if Pos('/H',Parm[i]) <> 0 then DisPlaySyntax;
For i := 1 to 3 do if Pos('/W',Parm[i]) <> 0 then Double := True;
For i := 1 to 3 do if Pos('/P',Parm[i]) <> 0 then Paging := False;
i := Pos('/',Fname);
If i <> 0 then Delete(Fname,i,Length(Fname));
If Fname = '' then Fname := '*.*';
begin
If not (Pos(':',Fname) in [0,2]) then
begin
WriteLn(#13#10'Invalid parameter'#13#10);
Halt(1);
end;
If Pos(':',Fname) = 0 then {If default drive}
begin {strip leading if current}
If Pos('\',Fname) = 1 then Delete(Fname,1,1);
If (Pos('.*',Fname) = 1) or (Pos('.?',Fname) = 1)
then Fname := '*' + Fname;
GetDir(0,DirStr); {get current WITH drive}
If Pos('..',Fname) = 1 then
begin
DirStr := Copy(DirStr,1,3);
Fname := '*.*';
end;
If Pos('\',DirStr) <> Length(DirStr) then DirStr := DirStr + '\';
Fname := DirStr + Fname; {tack curr dir on front}
x := Ord(Fname[1]); {get drive number}
If x > $60 then x := x - $60 else x := x - $40; {and fix it}
end
else
begin
x := ord(Fname[1]); {get drive number}
If x > $60 then x := x - $60 else x := x - $40; {and fix it}
GetDir(x,DirStr); {get that current dir}
If (Pos(':\',Fname) <> 2) then
begin
If Pos('\',DirStr) <> Length(DirStr) then DirStr := DirStr + '\';
Delete(Fname,1,2);
Fname := DirStr + Fname;
end;
end;
end;
DriveNo := x;
DName := Fname[1];
If Pos('\',Fname) <> 3 then Insert('\',Fname,3);
DirFound := False;
Dsize := DiskFree(DriveNo);
If DSize = -1 then { Diskfree returns $0FFFF if drive invalid }
{ but NO DosError and IOResult = 0 }
begin
WriteLn(#13#10,'Invalid drive ',Dname,':');
Halt(15); { Invalid drive error number in errorlevel }
end;
DirFound := True;
IsDir := False;
i := Length(Fname);
If (i > 3) and (Fname[i] = '\') then Delete(Fname,i,1);
If Length(Fname) = 3 then Fname := Fname + '*.*';
x := 0;
If ((Pos('?',Fname) = 0) and (Pos('*',Fname) = 0))
then
begin
Fblock.attr := 0;
FindFirst(Fname,$3f,Fblock);
x := Fblock.Attr;
end;
if ((x AND $10) <> 0) then IsDir := True;
If not IsDir and (Pos('.',Fname) = 0) then Fname := Fname + '.*';
ch := copy(Fname,Length(Fname),1);
If ((ch <> '*') and (ch <> '?')) and IsDir
then if (Copy(Fname,Length(Fname),1) <> '\')
then Fname := Fname + '\';
ch := copy(Fname,Length(Fname),1);
If (ch = '\') then FName := Fname + '*.*';
DosError := 0; {Clear any test errors}
end; {Procedure GetParms}
Procedure FixName; { Format filename and fill with spaces }
{ between name and extension for display }
Begin
WholeName := FBlock.Name;
i := Pos('.',WholeName);
j := Length(WholeName);
If i = 1 then
begin
If (WholeName = '.') then WholeName := '. ';
If (WholeName = '..') then WholeName := '.. ';
Exit;
end;
If i > 0 then
begin
Delete(WholeName,i,1);
for j := i to 9 do Insert(' ',WholeName,i);
for j := Length(WholeName) to 12 do
WholeName := Wholename + ' ';
end
else
for j := i to 12 do WholeName := WholeName + ' ';
end; {Procedure FixName}
Procedure MainLoop;
Begin
FixName;
Showit;
FindNext(Fblock);
end;
begin {Main Program}
Count := 0; { Initialize global variables }
DosError := 0;
FirstTime := True;
Paging := True;
GetParms; { Read the command line }
WriteLn;
Inc(Count); { Counter for screen and # files }
FindFirst(DName + ':\*.*',$8,Fblock);{ Get disk label and display if any}
If DosError <> 0 then WriteLn(
' Volume in',drive,Dname,' has no label')
else
WriteLn( ' Volume in',drive,Dname,' is ',FBlock.Name);
Inc(Count);
WriteLn(' Directory of ',Fname);
Inc(Count);
WriteLn;
Inc(Count);
FindFirst(Fname,$17,Fblock);
CheckForDosError;
While DosError = 0 do MainLoop;
If Odd(Count) and Double then WriteLn; { Program is over. Clean up, }
Write(Count - 4:5,' file(s) '); { We counted four extra lines }
{ adjust and show # files found}
WriteLn(DSize ,' bytes free on',drive,DName); { Show free space and end}
end. {Main Program}